home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / SYS_TOOL / MULTI020 / DUAL.PAS next >
Pascal/Delphi Source File  |  1993-09-05  |  2KB  |  86 lines
  1. unit Dual;
  2. { Unit which writes to the monochrome monitor (for debugging purposes).
  3.  
  4.   While Write(...) and WriteLn(...) write to your color screen,
  5.   Write(dual.t,...) and WriteLn(dual.t,...) write to the monochrome
  6.   screen, #8,#9,#10 and #13 are interpreted correctly.
  7.  
  8.   If there is no monochrome screen, your requests will be ignored.
  9.  
  10.   Read and ReadLn are not supported.
  11.  
  12.   The IDE or a debugger may get distorted by Dual. }
  13. interface
  14. uses dos;
  15. var
  16.   t : text;  { This is the text variable which outputs to the monochrome
  17.                monitor }
  18.  
  19. implementation
  20.  
  21. const
  22.   w : word = 0;
  23.  
  24. procedure WriteTTY(ch : char);
  25. begin
  26.   case ch of
  27.     #13: w := w div 80 * 80;
  28.     #10: if w < 24*80 then
  29.            inc(w,80)
  30.          else begin
  31.            move(mem[segB000:160],mem[segB000:0],24*160);
  32.            asm
  33.              mov es,[segB000]
  34.              mov di,24*160
  35.              mov cx,160
  36.              mov ax,$720
  37.              cld
  38.              rep stosw
  39.            end;
  40.          end;
  41.      #8: if w mod 80 > 0 then dec(w);
  42.      #9: w := w and $FFF8+8;
  43.     else begin
  44.            mem[segB000:w*2] := byte(ch);
  45.            mem[segB000:w*2+1] := 7;
  46.            inc(w); if w = 2000 then begin
  47.              dec(w,80);
  48.              writetty(#10)
  49.            end
  50.          end;
  51.   end
  52. end;
  53.  
  54. {$F+}
  55. function NewOut(var f : TextRec) : Integer;
  56. var i : Word;
  57. Begin
  58.   if w = $FFFF then exit;
  59.   With F do
  60.     if Bufpos > 0 then
  61.       for i := 0 to BufPos-1 do
  62.        WriteTTY(BufPtr^[i]);
  63.   F.Bufpos := 0; NewOut := 0;
  64.   port[$3B4] := 14; port[$3B5] := hi(w);
  65.   port[$3B4] := 15; port[$3B5] := lo(w)
  66. End;
  67. {$F-}
  68.  
  69. procedure AssignCRT(var f : text);
  70. begin
  71.   with TextRec(f) do begin
  72.     InOutFunc := @NewOut;
  73.     FlushFunc := @NewOut
  74.   end
  75. end;
  76.  
  77. begin
  78.   port[$3B4] := 14; w := word(port[$3B5]) shl 8;
  79.   port[$3B4] := 15; w := w + port[$3B5];
  80.   port[$3B5] := 77; if port[$3B5] <> 77 then w := $FFFF;
  81.   port[$3B5] := 99; if port[$3B5] <> 99 then w := $FFFF;
  82.   port[$3B5] := w and $FF;
  83.   assign(t,''); rewrite(t);
  84.   AssignCRT(t)
  85. end.
  86.